home *** CD-ROM | disk | FTP | other *** search
- (defmodule csp (standard0 semaphores loopsII list-fns) () (defconstant CSP-Error (make-instance condition-class (quote name) (quote CSP-Error) (quote direct-superclasses) (list condition) (quote direct-slot-descriptions) (list))) (progn (defconstant Abstract-Channel (make-instance structure-class (quote name) (quote Abstract-Channel) (quote direct-superclasses) (list structure) (quote direct-slot-descriptions) (list) (quote metaclass-hypotheses) nil)) (quote Abstract-Channel)) (defconstant c-read (make-instance generic-function (quote name) (quote c-read) (quote lambda-list) (quote (channel)) (quote method-class) method (quote methods) ())) (defconstant c-write (make-instance generic-function (quote name) (quote c-write) (quote lambda-list) (quote (channel data)) (quote method-class) method (quote methods) ())) (defconstant c-ready (make-instance generic-function (quote name) (quote c-ready) (quote lambda-list) (quote (channel)) (quote method-class) method (quote methods) ())) (defconstant is-csp-process (make-instance generic-function (quote name) (quote is-csp-process) (quote lambda-list) (quote (thread)) (quote method-class) method (quote methods) ())) (defconstant connect-channel-input (make-instance generic-function (quote name) (quote connect-channel-input) (quote lambda-list) (quote (channel)) (quote method-class) method (quote methods) ())) (defconstant connect-channel-output (make-instance generic-function (quote name) (quote connect-channel-output) (quote lambda-list) (quote (channel)) (quote method-class) method (quote methods) ())) (defun make-communication-sem () ((lambda (sem) (open-semaphore sem) sem) (make-semaphore))) (progn (defconstant Channel (make-instance structure-class (quote name) (quote Channel) (quote direct-superclasses) (list Abstract-Channel) (quote direct-slot-descriptions) (list (list (quote name) (quote data-ready) (quote slot-class) local-slot-description (quote slot-initargs) () (quote initargs) (quote ()) (quote initform) (lambda () nil)) (list (quote name) (quote in-sem) (quote slot-class) local-slot-description (quote slot-initargs) () (quote initargs) (quote ()) (quote initform) (lambda () (make-communication-sem))) (list (quote name) (quote out-sem) (quote slot-class) local-slot-description (quote slot-initargs) () (quote initargs) (quote ()) (quote initform) (lambda () (make-communication-sem))) (list (quote name) (quote datum) (quote slot-class) local-slot-description (quote slot-initargs) () (quote initargs) (quote ()) (quote initform) (lambda () (quote %_Should_not_be_seen_%))) (list (quote name) (quote connected) (quote slot-class) local-slot-description (quote slot-initargs) () (quote initargs) (quote ()) (quote initform) (lambda () nil)) (list (quote name) (quote input-thread) (quote slot-class) local-slot-description (quote slot-initargs) () (quote initargs) (quote ()) (quote initform) (lambda () nil)) (list (quote name) (quote output-thread) (quote slot-class) local-slot-description (quote slot-initargs) () (quote initargs) (quote ()) (quote initform) (lambda () nil))) (quote metaclass-hypotheses) nil)) (progn (defconstant Channel-output-thread (make-reader Channel (quote output-thread))) ((setter setter) Channel-output-thread (make-writer Channel (quote output-thread)))) (progn (defconstant Channel-input-thread (make-reader Channel (quote input-thread))) ((setter setter) Channel-input-thread (make-writer Channel (quote input-thread)))) (progn (defconstant Channel-connected (make-reader Channel (quote connected))) ((setter setter) Channel-connected (make-writer Channel (quote connected)))) (progn (defconstant Channel-datum (make-reader Channel (quote datum))) ((setter setter) Channel-datum (make-writer Channel (quote datum)))) (progn (defconstant Channel-out-sem (make-reader Channel (quote out-sem))) ((setter setter) Channel-out-sem (make-writer Channel (quote out-sem)))) (progn (defconstant Channel-in-sem (make-reader Channel (quote in-sem))) ((setter setter) Channel-in-sem (make-writer Channel (quote in-sem)))) (progn (defconstant Channel-data-ready (make-reader Channel (quote data-ready))) ((setter setter) Channel-data-ready (make-writer Channel (quote data-ready)))) (defconstant make-Channel (make-constructor Channel)) (quote Channel)) (progn (defconstant CSP-thread (make-instance thread-class (quote name) (quote CSP-thread) (quote direct-superclasses) (list thread) (quote direct-slot-descriptions) (list (list (quote name) (quote parent) (quote slot-class) local-slot-description (quote slot-initargs) () (quote initargs) (quote ()) (quote initform) (lambda () nil))) (quote metaclass-hypotheses) ())) (progn (defconstant CSP-thread-parent (make-reader CSP-thread (quote parent))) ((setter setter) CSP-thread-parent (make-writer CSP-thread (quote parent)))) (defconstant make-CSP-thread (make-constructor CSP-thread)) (quote CSP-thread)) (progn (add-method initialize-instance (make-instance (generic-function-method-class initialize-instance) (quote signature) (list CSP-thread object) (quote function) (lambda (***method-status-handle*** ***method-args-handle*** proto lst) ((lambda (new-thread) ((setter CSP-thread-parent) new-thread (current-thread)) new-thread) (if ***method-status-handle*** (apply call-method (cons (car ***method-status-handle***) ***method-args-handle***)) (error "No Next Method" Internal-Error nil))))))) (progn (add-method c-read (make-instance (generic-function-method-class c-read) (quote signature) (list Channel) (quote function) (lambda (***method-status-handle*** ***method-args-handle*** channel) (if (not (subthreadp (current-thread) (Channel-input-thread channel))) (progn (error "Read on wrong end: ~a~%" channel)) (if t (progn ((setter Channel-data-ready) channel nil) (open-semaphore (Channel-in-sem channel)) ((lambda (data) ((setter Channel-datum) channel nil) (close-semaphore (Channel-out-sem channel)) (thread-reschedule) data) (Channel-datum channel))) ())))))) (progn (add-method c-write (make-instance (generic-function-method-class c-write) (quote signature) (list Channel object) (quote function) (lambda (***method-status-handle*** ***method-args-handle*** channel data) (if (not (subthreadp (current-thread) (Channel-output-thread channel))) (progn (error "Write on wrong end: ~a~%" CSP-Error (quote error-value) channel)) ()) ((setter Channel-datum) channel data) (close-semaphore (Channel-in-sem channel)) ((setter Channel-data-ready) channel data) (open-semaphore (Channel-out-sem channel)) (thread-reschedule))))) (progn (add-method c-ready (make-instance (generic-function-method-class c-ready) (quote signature) (list Channel) (quote function) (lambda (***method-status-handle*** ***method-args-handle*** channel) (thread-reschedule) (Channel-data-ready channel))))) (progn (add-method connect-channel-input (make-instance (generic-function-method-class connect-channel-input) (quote signature) (list Channel) (quote function) (lambda (***method-status-handle*** ***method-args-handle*** channel) (if (Channel-input-thread channel) (progn (error "Can't reset channel input\n" (quote error-value) channel)) (if t (progn ((setter Channel-input-thread) channel (current-thread)) channel) ())))))) (progn (add-method connect-channel-output (make-instance (generic-function-method-class connect-channel-output) (quote signature) (list Channel) (quote function) (lambda (***method-status-handle*** ***method-args-handle*** channel) (if (Channel-output-thread channel) (progn (error "Can't reset channel output\n" Internal-Error (quote error-value) channel)) (if t (progn ((setter Channel-output-thread) channel (current-thread)) channel) ())))))) (progn (defconstant Chan-Pair (make-instance structure-class (quote name) (quote Chan-Pair) (quote direct-superclasses) (list Abstract-Channel) (quote direct-slot-descriptions) (list (list (quote name) (quote u-chan) (quote slot-class) local-slot-description (quote slot-initargs) () (quote initargs) (quote ()) (quote initform) (lambda () (make-instance Channel))) (list (quote name) (quote d-chan) (quote slot-class) local-slot-description (quote slot-initargs) () (quote initargs) (quote ()) (quote initform) (lambda () (make-instance Channel))) (list (quote name) (quote connect-count) (quote slot-class) local-slot-description (quote slot-initargs) () (quote initargs) (quote ()) (quote initform) (lambda () nil))) (quote metaclass-hypotheses) nil)) (progn (defconstant Chan-Pair-connect-count (make-reader Chan-Pair (quote connect-count))) ((setter setter) Chan-Pair-connect-count (make-writer Chan-Pair (quote connect-count)))) (progn (defconstant Chan-Pair-d-chan (make-reader Chan-Pair (quote d-chan))) ((setter setter) Chan-Pair-d-chan (make-writer Chan-Pair (quote d-chan)))) (progn (defconstant Chan-Pair-u-chan (make-reader Chan-Pair (quote u-chan))) ((setter setter) Chan-Pair-u-chan (make-writer Chan-Pair (quote u-chan)))) (defconstant make-Chan-Pair (make-constructor Chan-Pair)) (quote Chan-Pair)) (defconstant *pair-connect-lock* (make-semaphore)) (progn (defconstant Connected-Chan-Pair (make-instance structure-class (quote name) (quote Connected-Chan-Pair) (quote direct-superclasses) (list Abstract-Channel) (quote direct-slot-descriptions) (list (list (quote name) (quote input) (quote slot-class) local-slot-description (quote slot-initargs) () (quote initargs) (quote (input))) (list (quote name) (quote output) (quote slot-class) local-slot-description (quote slot-initargs) () (quote initargs) (quote (output)))) (quote metaclass-hypotheses) nil)) (progn (defconstant Connected-Chan-Pair-output (make-reader Connected-Chan-Pair (quote output))) ((setter setter) Connected-Chan-Pair-output (make-writer Connected-Chan-Pair (quote output)))) (progn (defconstant Connected-Chan-Pair-input (make-reader Connected-Chan-Pair (quote input))) ((setter setter) Connected-Chan-Pair-input (make-writer Connected-Chan-Pair (quote input)))) (defconstant make-Connected-Chan-Pair (make-constructor Connected-Chan-Pair)) (quote Connected-Chan-Pair)) (progn (add-method initialize-instance (make-instance (generic-function-method-class initialize-instance) (quote signature) (list Connected-Chan-Pair object) (quote function) (lambda (***method-status-handle*** ***method-args-handle*** proto lst) ((lambda (new-obj) (connect-channel-input (Connected-Chan-Pair-input new-obj)) (connect-channel-output (Connected-Chan-Pair-output new-obj)) new-obj) (if ***method-status-handle*** (apply call-method (cons (car ***method-status-handle***) ***method-args-handle***)) (error "No Next Method" Internal-Error nil))))))) (defun connect-chan-pair (chan-pair) (open-semaphore *pair-connect-lock*) (if (not (Chan-Pair-connect-count chan-pair)) (progn ((lambda (new-pair) ((setter Chan-Pair-connect-count) chan-pair (quote one)) (close-semaphore *pair-connect-lock*) new-pair) (make-Connected-Chan-Pair (quote input) (Chan-Pair-u-chan chan-pair) (quote output) (Chan-Pair-d-chan chan-pair)))) (if (eq (Chan-Pair-connect-count chan-pair) (quote one)) (progn ((lambda (new-pair) ((setter Chan-Pair-connect-count) chan-pair (quote two)) (close-semaphore *pair-connect-lock*) new-pair) (make-Connected-Chan-Pair (quote input) (Chan-Pair-d-chan chan-pair) (quote output) (Chan-Pair-u-chan chan-pair)))) (if t (progn (close-semaphore *pair-connect-lock*) (error "Tried to connect too often" CSP-Error (quote error-value) chan-pair)) ())))) (progn (add-method c-read (make-instance (generic-function-method-class c-read) (quote signature) (list Connected-Chan-Pair) (quote function) (lambda (***method-status-handle*** ***method-args-handle*** cp) (c-read (Connected-Chan-Pair-input cp)))))) (progn (add-method c-ready (make-instance (generic-function-method-class c-ready) (quote signature) (list Connected-Chan-Pair) (quote function) (lambda (***method-status-handle*** ***method-args-handle*** cp) (c-ready (Connected-Chan-Pair-input cp)))))) (progn (add-method c-write (make-instance (generic-function-method-class c-write) (quote signature) (list Connected-Chan-Pair object) (quote function) (lambda (***method-status-handle*** ***method-args-handle*** cp data) (c-write (Connected-Chan-Pair-output cp) data))))) (defun subthreadp (thread1 thread2) (if (eq thread1 thread2) (progn t) (if (eq (class-of thread1) thread) (progn nil) (if t (progn (subthreadp (CSP-thread-parent thread1) thread2)) ())))) (defun make-channel-vector (n) (mapvect make-Channel (make-vector n))) (defun await-finish (threads) ((lambda (res) res) (mapcar thread-value threads))) (defun make-ready-csp-thread (fn . args) ((lambda (thread) (apply thread-start (cons thread args)) thread) (make-CSP-thread (quote function) fn))) (deflocal *weather* (quote sunny)) (defun wait-for-ready-chan (lst) (wait-ready-aux (if (eq *weather* (quote sunny)) (progn (setq *weather* (quote rainy)) (reverse lst)) (if t (progn (setq *weather* (quote sunny)) lst) ())) nil)) (defun wait-ready-aux (orig-lst lst) (if (null lst) (progn (wait-ready-aux orig-lst orig-lst)) (if (c-ready (caar lst)) (progn (cdar lst)) (if t (progn (wait-ready-aux orig-lst (cdr lst))) ())))) (defmacro PAR tasks (cons (quote await-finish) (cons (cons (quote list) (append (mapcar starter tasks) ())) ()))) (defun starter (task) (cons (quote make-ready-csp-thread) (cons (cons (quote lambda) (cons () (cons task ()))) ()))) (defmacro FOR (inits cont-exp increment . body) (cons (quote let) (cons (cons (cons (quote @threads@) (cons (quote nil) ())) ()) (cons (cons (quote let) (cons (cons inits ()) (cons (cons (quote while) (cons cont-exp (cons (cons (quote setq) (cons (quote @threads@) (cons (cons (quote cons) (cons (cons (quote make-ready-csp-thread) (cons (cons (quote lambda) (cons (cons (car inits) ()) (append body ()))) (cons (car inits) ()))) (cons (quote @threads@) ()))) ()))) (cons increment ())))) ()))) (cons (cons (quote await-finish) (cons (quote @threads@) ())) ()))))) (defun MAPPAR (fn lst) (await-finish (mapcar (lambda (obj) (make-ready-csp-thread fn obj)) lst))) (defmacro SEQ jobs (cons (quote progn) (append jobs ()))) (defmacro ALT alternatives ((lambda (named-alternatives) (cons (quote let) (cons (cons (cons (quote @continue@) (cons (cons (quote wait-for-ready-chan) (cons (cons (quote collect) (cons (cons (quote lambda) (cons (cons (quote x) ()) (cons (quote x) ()))) (cons (cons (quote list) (append (mapcar make-guard named-alternatives) ())) ()))) ())) ())) ()) (cons (cons (quote cond) (append (append (mapcar make-alt-stmt named-alternatives) (quote (t (cerror t "Unexpected return from alt")))) ())) ())))) (mapcar (lambda (x) (name-alternative x)) alternatives))) (defun name-alternative (alternative) ((lambda (guard stmt) (if (eq (car guard) (quote IN)) (list (gensym) (cadr guard) (caddr guard) t stmt) (list (gensym) (cadr (reverse guard)) (caddr (reverse guard)) (cddr (reverse guard)) stmt))) (car alternative) (cdr alternative))) (defun make-guard (alt) (cons (quote if) (cons (cadddr alt) (cons (cons (quote cons) (cons (cadr alt) (cons (cons (quote quote) (cons (car alt) ())) ()))) (cons (quote nil) ()))))) (defun make-alt-stmt (alt) (cons (cons (quote eq) (cons (quote @continue@) (cons (cons (quote quote) (cons (car alt) ())) ()))) (cons (cons (quote let) (cons (cons (cons (caddr alt) (cons (cons (quote c-read) (cons (cadr alt) ())) ())) ()) (append (car (last-pair alt)) ()))) ()))) (defmacro IN-FROM (chan-data chans . rest) (cons (quote let*) (cons (cons (cons (car chan-data) (cons (cons (quote wait-for-ready-chan) (cons (cons (quote mapcar) (cons (cons (quote lambda) (cons (cons (quote x) ()) (cons (cons (quote cons) (cons (quote x) (cons (quote x) ()))) ()))) (cons chans ()))) ())) ())) (cons (cons (cadr chan-data) (cons (cons (quote IN) (cons (car chan-data) ())) ())) ())) (append rest ())))) (defmacro IN (chan . var) (if var (progn (cons (quote setq) (cons (car var) (cons (cons (quote c-read) (cons chan ())) ()))) (thread-reschedule)) (if t (progn (cons (quote c-read) (cons chan ()))) ()))) (defmacro OUT (chan value) (cons (quote progn) (cons (cons (quote c-write) (cons chan (cons value ()))) (cons (cons (quote thread-reschedule) ()) ())))) (export SEQ IN OUT ALT PAR FOR IN-FROM make-Channel make-Chan-Pair connect-channel-output connect-channel-input connect-chan-pair) (export await-finish starter make-ready-csp-thread make-alt-stmt make-guard wait-for-ready-chan c-write c-read c-ready))
